isnet Internet/Isnet Internet CD.iso/prog/hiz/09/09.exe/adynware.exe/perl/lib/Getopt/Long.pm

Perl POD Document | 1999-12-28 | 31.1 KB | 1,119 lines

package Getopt::Long;


=head1 NAME

GetOptions - extended processing of command line options

=head1 SYNOPSIS

  use Getopt::Long;
  $result = GetOptions (...option-descriptions...);

=head1 DESCRIPTION

The Getopt::Long module implements an extended getopt function called
GetOptions(). This function adheres to the POSIX syntax for command
line options, with GNU extensions. In general, this means that options
have long names instead of single letters, and are introduced with a
double dash "--". Support for bundling of command line options, as was
the case with the more traditional single-letter approach, is provided
but not enabled by default. For example, the UNIX "ps" command can be
given the command line "option"

  -vax

which means the combination of B<-v>, B<-a> and B<-x>. With the new
syntax B<--vax> would be a single option, probably indicating a
computer architecture.

Command line options can be used to set values. These values can be
specified in one of two ways:

  --size 24
  --size=24

GetOptions is called with a list of option-descriptions, each of which
consists of two elements: the option specifier and the option linkage.
The option specifier defines the name of the option and, optionally,
the value it can take. The option linkage is usually a reference to a
variable that will be set when the option is used. For example, the
following call to GetOptions:

  GetOptions("size=i" => \$offset);

will accept a command line option "size" that must have an integer
value. With a command line of "--size 24" this will cause the variable
$offset to get the value 24.

Alternatively, the first argument to GetOptions may be a reference to
a HASH describing the linkage for the options. The following call is
equivalent to the example above:

  %optctl = ("size" => \$offset);
  GetOptions(\%optctl, "size=i");

Linkage may be specified using either of the above methods, or both.
Linkage specified in the argument list takes precedence over the
linkage specified in the HASH.

The command line options are taken from array @ARGV. Upon completion
of GetOptions, @ARGV will contain the rest (i.e. the non-options) of
the command line.

Each option specifier designates the name of the option, optionally
followed by an argument specifier. Values for argument specifiers are:

=over 8

=item E<lt>noneE<gt>

Option does not take an argument.
The option variable will be set to 1.

=item !

Option does not take an argument and may be negated, i.e. prefixed by
"no". E.g. "foo!" will allow B<--foo> (with value 1) and B<-nofoo>
(with value 0).
The option variable will be set to 1, or 0 if negated.

=item =s

Option takes a mandatory string argument.
This string will be assigned to the option variable.
Note that even if the string argument starts with B<-> or B<-->, it
will not be considered an option on itself.

=item :s

Option takes an optional string argument.
This string will be assigned to the option variable.
If omitted, it will be assigned "" (an empty string).
If the string argument starts with B<-> or B<-->, it
will be considered an option on itself.

=item =i

Option takes a mandatory integer argument.
This value will be assigned to the option variable.
Note that the value may start with B<-> to indicate a negative
value.

=item :i

Option takes an optional integer argument.
This value will be assigned to the option variable.
If omitted, the value 0 will be assigned.
Note that the value may start with B<-> to indicate a negative
value.

=item =f

Option takes a mandatory real number argument.
This value will be assigned to the option variable.
Note that the value may start with B<-> to indicate a negative
value.

=item :f

Option takes an optional real number argument.
This value will be assigned to the option variable.
If omitted, the value 0 will be assigned.

=back

A lone dash B<-> is considered an option, the corresponding option
name is the empty string.

A double dash on itself B<--> signals end of the options list.

=head2 Linkage specification

The linkage specifier is optional. If no linkage is explicitly
specified but a ref HASH is passed, GetOptions will place the value in
the HASH. For example:

  %optctl = ();
  GetOptions (\%optctl, "size=i");

will perform the equivalent of the assignment

  $optctl{"size"} = 24;

For array options, a reference to an array is used, e.g.:

  %optctl = ();
  GetOptions (\%optctl, "sizes=i@");

with command line "-sizes 24 -sizes 48" will perform the equivalent of
the assignment

  $optctl{"sizes"} = [24, 48];

For hash options (an option whose argument looks like "name=value"),
a reference to a hash is used, e.g.:

  %optctl = ();
  GetOptions (\%optctl, "define=s%");

with command line "--define foo=hello --define bar=world" will perform the
equivalent of the assignment

  $optctl{"define"} = {foo=>'hello', bar=>'world')

If no linkage is explicitly specified and no ref HASH is passed,
GetOptions will put the value in a global variable named after the
option, prefixed by "opt_". To yield a usable Perl variable,
characters that are not part of the syntax for variables are
translated to underscores. For example, "--fpp-struct-return" will set
the variable $opt_fpp_struct_return. Note that this variable resides
in the namespace of the calling program, not necessarily B<main>.
For example:

  GetOptions ("size=i", "sizes=i@");

with command line "-size 10 -sizes 24 -sizes 48" will perform the
equivalent of the assignments

  $opt_size = 10;
  @opt_sizes = (24, 48);

A lone dash B<-> is considered an option, the corresponding Perl
identifier is $opt_ .

The linkage specifier can be a reference to a scalar, a reference to
an array, a reference to a hash or a reference to a subroutine.

If a REF SCALAR is supplied, the new value is stored in the referenced
variable. If the option occurs more than once, the previous value is
overwritten.

If a REF ARRAY is supplied, the new value is appended (pushed) to the
referenced array.

If a REF HASH is supplied, the option value should look like "key" or
"key=value" (if the "=value" is omitted then a value of 1 is implied).
In this case, the element of the referenced hash with the key "key"
is assigned "value".

If a REF CODE is supplied, the referenced subroutine is called with
two arguments: the option name and the option value.
The option name is always the true name, not an abbreviation or alias.

=head2 Aliases and abbreviations

The option name may actually be a list of option names, separated by
"|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name
of this option. If no linkage is specified, options "foo", "bar" and
"blech" all will set $opt_foo.

Option names may be abbreviated to uniqueness, depending on
configuration option B<auto_abbrev>.

=head2 Non-option call-back routine

A special option specifier, E<lt>E<gt>, can be used to designate a subroutine
to handle non-option arguments. GetOptions will immediately call this
subroutine for every non-option it encounters in the options list.
This subroutine gets the name of the non-option passed.
This feature requires configuration option B<permute>, see section
CONFIGURATION OPTIONS.

See also the examples.

=head2 Option starters

On the command line, options can start with B<-> (traditional), B<-->
(POSIX) and B<+> (GNU, now being phased out). The latter is not
allowed if the environment variable B<POSIXLY_CORRECT> has been
defined.

Options that start with "--" may have an argument appended, separated
with an "=", e.g. "--foo=bar".

=head2 Return value

A return status of 0 (false) indicates that the function detected
one or more errors.

=head1 COMPATIBILITY

Getopt::Long::GetOptions() is the successor of
B<newgetopt.pl> that came with Perl 4. It is fully upward compatible.
In fact, the Perl 5 version of newgetopt.pl is just a wrapper around
the module.

If an "@" sign is appended to the argument specifier, the option is
treated as an array. Value(s) are not set, but pushed into array
@opt_name. If explicit linkage is supplied, this must be a reference
to an ARRAY.

If an "%" sign is appended to the argument specifier, the option is
treated as a hash. Value(s) of the form "name=value" are set by
setting the element of the hash %opt_name with key "name" to "value"
(if the "=value" portion is omitted it defaults to 1). If explicit
linkage is supplied, this must be a reference to a HASH.

If configuration option B<getopt_compat> is set (see section
CONFIGURATION OPTIONS), options that start with "+" or "-" may also
include their arguments, e.g. "+foo=bar". This is for compatiblity
with older implementations of the GNU "getopt" routine.

If the first argument to GetOptions is a string consisting of only
non-alphanumeric characters, it is taken to specify the option starter
characters. Everything starting with one of these characters from the
starter will be considered an option. B<Using a starter argument is
strongly deprecated.>

For convenience, option specifiers may have a leading B<-> or B<-->,
so it is possible to write:

   GetOptions qw(-foo=s --bar=i --ar=s);

=head1 EXAMPLES

If the option specifier is "one:i" (i.e. takes an optional integer
argument), then the following situations are handled:

   -one -two        -> $opt_one = '', -two is next option
   -one -2        -> $opt_one = -2

Also, assume specifiers "foo=s" and "bar:s" :

   -bar -xxx        -> $opt_bar = '', '-xxx' is next option
   -foo -bar        -> $opt_foo = '-bar'
   -foo --        -> $opt_foo = '--'

In GNU or POSIX format, option names and values can be combined:

   +foo=blech        -> $opt_foo = 'blech'
   --bar=        -> $opt_bar = ''
   --bar=--        -> $opt_bar = '--'

Example of using variable references:

   $ret = GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar);

With command line options "-foo blech -bar 24 -ar xx -ar yy"
this will result in:

   $foo = 'blech'
   $opt_bar = 24
   @ar = ('xx','yy')

Example of using the E<lt>E<gt> option specifier:

   @ARGV = qw(-foo 1 bar -foo 2 blech);
   GetOptions("foo=i", \$myfoo, "<>", \&mysub);

Results:

   mysub("bar") will be called (with $myfoo being 1)
   mysub("blech") will be called (with $myfoo being 2)

Compare this with:

   @ARGV = qw(-foo 1 bar -foo 2 blech);
   GetOptions("foo=i", \$myfoo);

This will leave the non-options in @ARGV:

   $myfoo -> 2
   @ARGV -> qw(bar blech)

=head1 CONFIGURATION OPTIONS

B<GetOptions> can be configured by calling subroutine
B<Getopt::Long::config>. This subroutine takes a list of quoted
strings, each specifying a configuration option to be set, e.g.
B<ignore_case>. Options can be reset by prefixing with B<no_>, e.g.
B<no_ignore_case>. Case does not matter. Multiple calls to B<config>
are possible.

Previous versions of Getopt::Long used variables for the purpose of
configuring. Although manipulating these variables still work, it
is strongly encouraged to use the new B<config> routine. Besides, it
is much easier.

The following options are available:

=over 12

=item default

This option causes all configuration options to be reset to their
default values.

=item auto_abbrev

Allow option names to be abbreviated to uniqueness.
Default is set unless environment variable
POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset.

=item getopt_compat

Allow '+' to start options.
Default is set unless environment variable
POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset.

=item require_order

Whether non-options are allowed to be mixed with
options.
Default is set unless environment variable
POSIXLY_CORRECT has been set, in which case b<require_order> is reset.

See also B<permute>, which is the opposite of B<require_order>.

=item permute

Whether non-options are allowed to be mixed with
options.
Default is set unless environment variable
POSIXLY_CORRECT has been set, in which case B<permute> is reset.
Note that B<permute> is the opposite of B<require_order>.

If B<permute> is set, this means that

    -foo arg1 -bar arg2 arg3

is equivalent to

    -foo -bar arg1 arg2 arg3

If a non-option call-back routine is specified, @ARGV will always be
empty upon succesful return of GetOptions since all options have been
processed, except when B<--> is used:

    -foo arg1 -bar arg2 -- arg3

will call the call-back routine for arg1 and arg2, and terminate
leaving arg2 in @ARGV.

If B<require_order> is set, options processing
terminates when the first non-option is encountered.

    -foo arg1 -bar arg2 arg3

is equivalent to

    -foo -- arg1 -bar arg2 arg3

=item bundling (default: reset)

Setting this variable to a non-zero value will allow single-character
options to be bundled. To distinguish bundles from long option names,
long options must be introduced with B<--> and single-character
options (and bundles) with B<->. For example,

    ps -vax --vax

would be equivalent to

    ps -v -a -x --vax

provided "vax", "v", "a" and "x" have been defined to be valid
options.

Bundled options can also include a value in the bundle; this value has
to be the last part of the bundle, e.g.

    scale -h24 -w80

is equivalent to

    scale -h 24 -w 80

Note: resetting B<bundling> also resets B<bundling_override>.

=item bundling_override (default: reset)

If B<bundling_override> is set, bundling is enabled as with
B<bundling> but now long option names override option bundles. In the
above example, B<-vax> would be interpreted as the option "vax", not
the bundle "v", "a", "x".

Note: resetting B<bundling_override> also resets B<bundling>.

B<Note:> Using option bundling can easily lead to unexpected results,
especially when mixing long options and bundles. Caveat emptor.

=item ignore_case  (default: set)

If set, case is ignored when matching options.

Note: resetting B<ignore_case> also resets B<ignore_case_always>.

=item ignore_case_always (default: reset)

When bundling is in effect, case is ignored on single-character
options also.

Note: resetting B<ignore_case_always> also resets B<ignore_case>.

=item pass_through (default: reset)

Unknown options are passed through in @ARGV instead of being flagged
as errors. This makes it possible to write wrapper scripts that
process only part of the user supplied options, and passes the
remaining options to some other program.

This can be very confusing, especially when B<permute> is also set.

=item debug (default: reset)

Enable copious debugging output.

=back

=head1 OTHER USEFUL VARIABLES

=over 12

=item $Getopt::Long::VERSION

The version number of this Getopt::Long implementation in the format
C<major>.C<minor>. This can be used to have Exporter check the
version, e.g.

    use Getopt::Long 3.00;

You can inspect $Getopt::Long::major_version and
$Getopt::Long::minor_version for the individual components.

=item $Getopt::Long::error

Internal error flag. May be incremented from a call-back routine to
cause options parsing to fail.

=back

=cut




use strict;

BEGIN {
    require 5.003;
    use Exporter ();
    use vars   qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
    $VERSION   = sprintf("%d.%02d", q$Revision: 2.10 $ =~ /(\d+)\.(\d+)/);

    @ISA       = qw(Exporter);
    @EXPORT    = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
    %EXPORT_TAGS = ();
    @EXPORT_OK = qw();
}

use vars @EXPORT, @EXPORT_OK;
use vars qw($error $debug $major_version $minor_version);
use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
        $passthrough);


my $gen_prefix;            # generic prefix (option starters)
my $argend;            # option list terminator
my %opctl;            # table of arg.specs (long and abbrevs)
my %bopctl;            # table of arg.specs (bundles)
my @opctl;            # the possible long option names
my $pkg;            # current context. Needed if no linkage.
my %aliases;            # alias table
my $genprefix;            # so we can call the same module more
my $opt;            # current option
my $arg;            # current option value, if any
my $array;            # current option is array typed
my $hash;            # current option is hash typed
my $key;            # hash key for a hash option
my $config_defaults;        # set config defaults
my $find_option;        # helper routine


sub GetOptions {

    my @optionlist = @_;    # local copy of the option descriptions
    $argend = '--';        # option list terminator
    %opctl = ();        # table of arg.specs (long and abbrevs)
    %bopctl = ();        # table of arg.specs (bundles)
    $pkg = (caller)[0];        # current context
    %aliases= ();        # alias table
    my @ret = ();        # accum for non-options
    my %linkage;        # linkage
    my $userlinkage;        # user supplied HASH
    $genprefix = $gen_prefix;    # so we can call the same module many times
    $error = 0;

    print STDERR ('GetOptions $Revision: 2.10 $ ',
          "[GetOpt::Long $Getopt::Long::VERSION] -- ",
          "called from package \"$pkg\".\n",
          "  (@ARGV)\n",
          "  autoabbrev=$autoabbrev".
          ",bundling=$bundling",
          ",getopt_compat=$getopt_compat",
          ",order=$order",
          ",\n  ignorecase=$ignorecase",
          ",passthrough=$passthrough",
          ",genprefix=\"$genprefix\"",
          ".\n")
    if $debug;

    $userlinkage = undef;
    if ( ref($optionlist[0]) && ref($optionlist[0]) eq 'HASH' ) {
    $userlinkage = shift (@optionlist);
    }

    if ( $optionlist[0] =~ /^\W+$/ ) {
    $genprefix = shift (@optionlist);
    $genprefix =~ s/(\W)/\\$1/g;
    $genprefix = "[" . $genprefix . "]";
    }

    %opctl = ();
    %bopctl = ();
    while ( @optionlist > 0 ) {
    my $opt = shift (@optionlist);

    $opt = $' if $opt =~ /^($genprefix)+/;

    if ( $opt eq '<>' ) {
        if ( (defined $userlinkage)
        && !(@optionlist > 0 && ref($optionlist[0]))
        && (exists $userlinkage->{$opt})
        && ref($userlinkage->{$opt}) ) {
        unshift (@optionlist, $userlinkage->{$opt});
        }
        unless ( @optionlist > 0
            && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
        warn ("Option spec <> requires a reference to a subroutine\n");
        $error++;
        next;
        }
        $linkage{'<>'} = shift (@optionlist);
        next;
    }

    if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse][@%]?)?$/ ) {
        warn ("Error in option spec: \"", $opt, "\"\n");
        $error++;
        next;
    }
    my ($o, $c, $a) = ($1, $2);
    $c = '' unless defined $c;

    if ( ! defined $o ) {
        $opctl{$o = ''} = $c;
    }
    else {
        my @o =  split (/\|/, $o);
        my $linko = $o = $o[0];
        $a = $o unless $o eq lc($o);
        $o = lc ($o)
        if $ignorecase > 1
            || ($ignorecase
            && ($bundling ? length($o) > 1  : 1));

        foreach ( @o ) {
        if ( $bundling && length($_) == 1 ) {
            $_ = lc ($_) if $ignorecase > 1;
            if ( $c eq '!' ) {
            $opctl{"no$_"} = $c;
            warn ("Ignoring '!' modifier for short option $_\n");
            $c = '';
            }
            $opctl{$_} = $bopctl{$_} = $c;
        }
        else {
            $_ = lc ($_) if $ignorecase;
            if ( $c eq '!' ) {
            $opctl{"no$_"} = $c;
            $c = '';
            }
            $opctl{$_} = $c;
        }
        if ( defined $a ) {
            $aliases{$_} = $a;
        }
        else {
            $a = $_;
        }
        }
        $o = $linko;
    }

    if ( defined $userlinkage ) {
        unless ( @optionlist > 0 && ref($optionlist[0]) ) {
        if ( exists $userlinkage->{$o} && ref($userlinkage->{$o}) ) {
            print STDERR ("=> found userlinkage for \"$o\": ",
                  "$userlinkage->{$o}\n")
            if $debug;
            unshift (@optionlist, $userlinkage->{$o});
        }
        else {
            next;
        }
        }
    }

    if ( @optionlist > 0 && ref($optionlist[0]) ) {
        print STDERR ("=> link \"$o\" to $optionlist[0]\n")
        if $debug;
        if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) {
        $linkage{$o} = shift (@optionlist);
        }
        elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) {
        $linkage{$o} = shift (@optionlist);
        $opctl{$o} .= '@'
          if $opctl{$o} ne '' and $opctl{$o} !~ /\@$/;
        $bopctl{$o} .= '@'
          if $bundling and $bopctl{$o} ne '' and $bopctl{$o} !~ /\@$/;
        }
        elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) {
        $linkage{$o} = shift (@optionlist);
        $opctl{$o} .= '%'
          if $opctl{$o} ne '' and $opctl{$o} !~ /\%$/;
        $bopctl{$o} .= '%'
          if $bundling and $bopctl{$o} ne '' and $bopctl{$o} !~ /\%$/;
        }
        else {
        warn ("Invalid option linkage for \"", $opt, "\"\n");
        $error++;
        }
    }
    else {
        my $ov = $o;
        $ov =~ s/\W/_/g;
        if ( $c =~ /@/ ) {
        print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n")
            if $debug;
        eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;");
        }
        elsif ( $c =~ /%/ ) {
        print STDERR ("=> link \"$o\" to \%$pkg","::opt_$ov\n")
            if $debug;
        eval ("\$linkage{\$o} = \\\%".$pkg."::opt_$ov;");
        }
        else {
        print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n")
            if $debug;
        eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;");
        }
    }
    }

    return 0 if $error;

    @opctl = sort(keys (%opctl)) if $autoabbrev;

    if ( $debug ) {
    my ($arrow, $k, $v);
    $arrow = "=> ";
    while ( ($k,$v) = each(%opctl) ) {
        print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
        $arrow = "   ";
    }
    $arrow = "=> ";
    while ( ($k,$v) = each(%bopctl) ) {
        print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n");
        $arrow = "   ";
    }
    }

    while ( @ARGV > 0 ) {


    $opt = shift (@ARGV);
    $arg = undef;
    $array = $hash = 0;
    print STDERR ("=> option \"", $opt, "\"\n") if $debug;


    if ( $opt eq $argend ) {
        unshift (@ARGV, @ret)
        if $order == $PERMUTE;
        return ($error == 0);
    }

    my $tryopt = $opt;

    if ( &$find_option () ) {

        next unless defined $opt;

        if ( defined $arg ) {
        $opt = $aliases{$opt} if defined $aliases{$opt};

        if ( defined $linkage{$opt} ) {
            print STDERR ("=> ref(\$L{$opt}) -> ",
                  ref($linkage{$opt}), "\n") if $debug;

            if ( ref($linkage{$opt}) eq 'SCALAR' ) {
            print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") if $debug;
            ${$linkage{$opt}} = $arg;
            }
            elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
            print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
                if $debug;
            push (@{$linkage{$opt}}, $arg);
            }
            elsif ( ref($linkage{$opt}) eq 'HASH' ) {
            print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
                if $debug;
            $linkage{$opt}->{$key} = $arg;
            }
            elsif ( ref($linkage{$opt}) eq 'CODE' ) {
            print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n")
                if $debug;
            &{$linkage{$opt}}($opt, $arg);
            }
            else {
            print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
                      "\" in linkage\n");
            die ("Getopt::Long -- internal error!\n");
            }
        }
        elsif ( $array ) {
            if ( defined $userlinkage->{$opt} ) {
            print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
                if $debug;
            push (@{$userlinkage->{$opt}}, $arg);
            }
            else {
            print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
                if $debug;
            $userlinkage->{$opt} = [$arg];
            }
        }
        elsif ( $hash ) {
            if ( defined $userlinkage->{$opt} ) {
            print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
                if $debug;
            $userlinkage->{$opt}->{$key} = $arg;
            }
            else {
            print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
                if $debug;
            $userlinkage->{$opt} = {$key => $arg};
            }
        }
        else {
            print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
            $userlinkage->{$opt} = $arg;
        }
        }
    }

    elsif ( $order == $PERMUTE ) {
        my $cb;
        if ( (defined ($cb = $linkage{'<>'})) ) {
        &$cb($tryopt);
        }
        else {
        print STDERR ("=> saving \"$tryopt\" ",
                  "(not an option, may permute)\n") if $debug;
        push (@ret, $tryopt);
        }
        next;
    }

    else {
        unshift (@ARGV, $tryopt);
        return ($error == 0);
    }

    }

    if ( $order == $PERMUTE ) {
    print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
        if $debug && @ret > 0;
    unshift (@ARGV, @ret) if @ret > 0;
    }

    return ($error == 0);
}

sub config (@) {
    my (@options) = @_;
    my $opt;
    foreach $opt ( @options ) {
    my $try = lc ($opt);
    my $action = 1;
    if ( $try =~ /^no_?/ ) {
        $action = 0;
        $try = $';
    }
    if ( $try eq 'default' or $try eq 'defaults' ) {
        &$config_defaults () if $action;
    }
    elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
        $autoabbrev = $action;
    }
    elsif ( $try eq 'getopt_compat' ) {
        $getopt_compat = $action;
    }
    elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
        $ignorecase = $action;
    }
    elsif ( $try eq 'ignore_case_always' ) {
        $ignorecase = $action ? 2 : 0;
    }
    elsif ( $try eq 'bundling' ) {
        $bundling = $action;
    }
    elsif ( $try eq 'bundling_override' ) {
        $bundling = $action ? 2 : 0;
    }
    elsif ( $try eq 'require_order' ) {
        $order = $action ? $REQUIRE_ORDER : $PERMUTE;
    }
    elsif ( $try eq 'permute' ) {
        $order = $action ? $PERMUTE : $REQUIRE_ORDER;
    }
    elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
        $passthrough = $action;
    }
    elsif ( $try eq 'debug' ) {
        $debug = $action;
    }
    else {
        $Carp::CarpLevel = 1;
        Carp::croak("Getopt::Long: unknown config parameter \"$opt\"")
    }
    }
}

sub require_version {
    no strict;
    my ($self, $wanted) = @_;
    my $pkg = ref $self || $self;
    my $version = $ {"${pkg}::VERSION"} || "(undef)";

    $wanted .= '.0' unless $wanted =~ /\./;
    $wanted = $1 * 1000 + $2 if $wanted =~ /^(\d+)\.(\d+)$/;
    $version = $1 * 1000 + $2 if $version =~ /^(\d+)\.(\d+)$/;
    if ( $version < $wanted ) {
    $version =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e;
    $wanted =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e;
    $Carp::CarpLevel = 1;
    Carp::croak("$pkg $wanted required--this is only version $version")
    }
    $version;
}


$find_option = sub {

    return 0 unless $opt =~ /^$genprefix/;

    $opt = $';
    my ($starter) = $&;

    my $optarg = undef;    # value supplied with --opt=value
    my $rest = undef;    # remainder from unbundling

    if (($starter eq "--" || $getopt_compat)
    && $opt =~ /^([^=]+)=/ ) {
    $opt = $1;
    $optarg = $';
    print STDERR ("=> option \"", $opt,
              "\", optarg = \"$optarg\"\n") if $debug;
    }


    my $tryopt = $opt;        # option to try
    my $optbl = \%opctl;    # table to look it up (long names)
    my $type;

    if ( $bundling && $starter eq '-' ) {
    $rest = substr ($tryopt, 1);
    $tryopt = substr ($tryopt, 0, 1);
    $tryopt = lc ($tryopt) if $ignorecase > 1;
    print STDERR ("=> $starter$tryopt unbundled from ",
              "$starter$tryopt$rest\n") if $debug;
    $rest = undef unless $rest ne '';
    $optbl = \%bopctl;    # look it up in the short names table

    if ( $bundling == 2 and
         defined ($type = $opctl{$tryopt.$rest}) ) {
        print STDERR ("=> $starter$tryopt rebundled to ",
              "$starter$tryopt$rest\n") if $debug;
        $tryopt .= $rest;
        undef $rest;
    }
    }

    elsif ( $autoabbrev ) {
    $tryopt = $opt = lc ($opt) if $ignorecase;
    my $pat = quotemeta ($opt);
    my @hits = grep (/^$pat/, @opctl);
    print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
              "out of ", scalar(@opctl), "\n") if $debug;

    unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
        my %hit;
        foreach ( @hits ) {
        $_ = $aliases{$_} if defined $aliases{$_};
        $hit{$_} = 1;
        }
        unless ( keys(%hit) == 1 ) {
        return 0 if $passthrough;
        print STDERR ("Option ", $opt, " is ambiguous (",
                  join(", ", @hits), ")\n");
        $error++;
        undef $opt;
        return 1;
        }
        @hits = keys(%hit);
    }

    if ( @hits == 1 && $hits[0] ne $opt ) {
        $tryopt = $hits[0];
        $tryopt = lc ($tryopt) if $ignorecase;
        print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
        if $debug;
    }
    }

    elsif ( $ignorecase ) {
    $tryopt = lc ($opt);
    }

    $type = $optbl->{$tryopt} unless defined $type;
    unless  ( defined $type ) {
    return 0 if $passthrough;
    warn ("Unknown option: ", $opt, "\n");
    $error++;
    return 1;
    }
    $opt = $tryopt;
    print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;


    if ( $type eq '' || $type eq '!' ) {
    if ( defined $optarg ) {
        return 0 if $passthrough;
        print STDERR ("Option ", $opt, " does not take an argument\n");
        $error++;
        undef $opt;
    }
    elsif ( $type eq '' ) {
        $arg = 1;        # supply explicit value
    }
    else {
        substr ($opt, 0, 2) = ''; # strip NO prefix
        $arg = 0;        # supply explicit value
    }
    unshift (@ARGV, $starter.$rest) if defined $rest;
    return 1;
    }

    my $mand;
    ($mand, $type, $array, $hash) = $type =~ /^(.)(.)(@?)(%?)$/;

    if ( defined $optarg ? ($optarg eq '')
     : !(defined $rest || @ARGV > 0) ) {
    if ( $mand eq "=" ) {
        return 0 if $passthrough;
        print STDERR ("Option ", $opt, " requires an argument\n");
        $error++;
        undef $opt;
    }
    if ( $mand eq ":" ) {
        $arg = $type eq "s" ? '' : 0;
    }
    return 1;
    }

    $arg = (defined $rest ? $rest
        : (defined $optarg ? $optarg : shift (@ARGV)));

    $key = undef;
    if ($hash && defined $arg) {
    ($key, $arg) = ($arg =~ /=/o) ? ($`, $') : ($arg, 1);
    }


    if ( $type eq "s" ) {    # string
    return 1 if $mand eq "=";

    return 1 if defined $optarg || defined $rest;
    return 1 if $arg eq "-"; # ??

    if ($arg eq $argend ||
        $arg =~ /^$genprefix.+/) {
        unshift (@ARGV, $arg);
        $arg = '';
    }
    }

    elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer
    if ( $arg !~ /^-?[0-9]+$/ ) {
        if ( defined $optarg || $mand eq "=" ) {
        return 0 if $passthrough;
        print STDERR ("Value \"", $arg, "\" invalid for option ",
                  $opt, " (number expected)\n");
        $error++;
        undef $opt;
        unshift (@ARGV, $starter.$rest) if defined $rest;
        }
        else {
        unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
        $arg = 0;
        }
    }
    }

    elsif ( $type eq "f" ) { # real number, int is also ok
    if ( $arg !~ /^-?[0-9.]+([eE]-?[0-9]+)?$/ ) {
        if ( defined $optarg || $mand eq "=" ) {
        return 0 if  $passthrough;
        print STDERR ("Value \"", $arg, "\" invalid for option ",
                  $opt, " (real number expected)\n");
        $error++;
        undef $opt;
        unshift (@ARGV, $starter.$rest) if defined $rest;
        }
        else {
        unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
        $arg = 0.0;
        }
    }
    }
    else {
    die ("GetOpt::Long internal error (Can't happen)\n");
    }
    return 1;
};

$config_defaults = sub {
    if ( defined $ENV{"POSIXLY_CORRECT"} ) {
    $gen_prefix = "(--|-)";
    $autoabbrev = 0;        # no automatic abbrev of options
    $bundling = 0;            # no bundling of single letter switches
    $getopt_compat = 0;        # disallow '+' to start options
    $order = $REQUIRE_ORDER;
    }
    else {
    $gen_prefix = "(--|-|\\+)";
    $autoabbrev = 1;        # automatic abbrev of options
    $bundling = 0;            # bundling off by default
    $getopt_compat = 1;        # allow '+' to start options
    $order = $PERMUTE;
    }
    $debug = 0;            # for debugging
    $error = 0;            # error tally
    $ignorecase = 1;        # ignore case when matching options
    $passthrough = 0;        # leave unrecognized options alone
};


($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;

&$config_defaults ();


1;